home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp.lbr / XLEVAL.CQ / xleval.c
Encoding:
C/C++ Source or Header  |  1985-06-03  |  8.9 KB  |  312 lines
  1.                           /* XLISP evaluation module */
  2.  
  3. #ifdef CI_86
  4. #include "a:stdio.h"
  5. #include "xlisp.h"
  6. #endif
  7.  
  8.  
  9. #ifdef AZTEC
  10. #include "a:stdio.h"
  11. #include "a:setjmp.h"
  12. #include "xlisp.h"
  13. #endif
  14.  
  15. #ifdef unix
  16. #include <stdio.h>
  17. #include <setjmp.h>
  18. #include <xlisp.h>
  19. #endif
  20.  
  21.  
  22.                              /* global variables */
  23.     struct node *xlstack;
  24.  
  25.                                 /* trace stack */
  26.     static struct node *trace_stack[TDEPTH];
  27.     static int trace_pointer;
  28.  
  29.                             /* external variables */
  30.     extern struct node *xlenv;
  31.  
  32.                               /* local variables */
  33.     static struct node *slash;
  34.  
  35.            /* forward declarations (the extern hack is for decusc) */
  36.     extern struct node *evlist();
  37.     extern struct node *evsym();
  38.     extern struct node *evfun();
  39.  
  40.  
  41.                     /***************************************
  42.                     *  eval - the builtin function 'eval'  *
  43.                     ***************************************/
  44.  
  45. static struct node *eval(args)
  46.     struct node *args;
  47. {
  48.     struct node *oldstk,expr,*val;
  49.  
  50.     oldstk = xlsave(&expr,NULL);                 /* Create new stack frame */
  51.  
  52.     expr.n_ptr = xlevarg(&args);                 /* Expression to evaluate */
  53.     xllastarg(args);                             /* No more args ! */
  54.  
  55.     val = xleval(expr.n_ptr);                    /* Do evaluation */
  56.  
  57.     xlstack = oldstk;                            /* Restore old stack frame */
  58.     return (val);
  59. }
  60.  
  61.                    /******************************************
  62.                    *  xleval - evaluate an xlisp expression  *
  63.                    ******************************************/
  64.  
  65.  
  66. struct node *xleval(expr)
  67.     struct node *expr;
  68. {
  69.     if (expr == NULL)                            /* Null evaluates to null */
  70.         return (NULL);
  71.  
  72.     switch (expr->n_type)                        /* Value type */
  73.     {
  74.     case LIST:
  75.             return (evlist(expr));
  76.  
  77.     case SYM:
  78.             return (evsym(expr));
  79.  
  80.     case INT:
  81.     case STR:
  82.     case SUBR:
  83.     case REAL:
  84.             return (expr);
  85.  
  86.     default:
  87.             xlfail("can't evaluate expression");
  88.     }
  89. }
  90.  
  91.  
  92.  
  93.                      /*************************************
  94.                      *  xlsave - save nodes on the stack  *
  95.                      *************************************/
  96.  
  97. struct node *xlsave(n)
  98.     struct node *n;
  99. {
  100.     struct node **nptr,*oldstk;
  101.  
  102.     oldstk = xlstack;                            /* Save old stack pointer */
  103.  
  104.     for (nptr = &n; *nptr != NULL; nptr++)       /* Save for each node */
  105.     {
  106.         (*nptr)->n_type = LIST;
  107.         (*nptr)->n_listvalue = NULL;
  108.         (*nptr)->n_listnext = xlstack;
  109.         xlstack = *nptr;
  110.     }
  111.  
  112.     return (oldstk);                             /* Return old stack pointer */
  113. }
  114.  
  115.  
  116.  
  117.                          /*****************************
  118.                          *  evlist - evaluate a list  *
  119.                          *****************************/
  120.  
  121. static struct node *evlist(nptr)
  122.     struct node *nptr;
  123. {
  124.     struct node *oldstk,fun,args,*val;
  125.  
  126.     oldstk = xlsave(&fun,&args,NULL);            /* Creat a stack frame */
  127.  
  128.     fun.n_ptr = nptr->n_listvalue;               /* Get function and arg list */
  129.     args.n_ptr = nptr->n_listnext;
  130.  
  131.     tpush(nptr);                                 /* Add trace entry */
  132.  
  133.     if ((fun.n_ptr = xleval(fun.n_ptr)) == NULL) /* Evaluate first expression */
  134.         xlfail("null function");
  135.  
  136.     switch (fun.n_ptr->n_type)                   /* Evaluate function */
  137.     {
  138.     case SUBR:
  139.             val = (*fun.n_ptr->n_subr)(args.n_ptr);
  140.             break;
  141.  
  142.     case LIST:
  143.             val = evfun(fun.n_ptr,args.n_ptr);
  144.             break;
  145.  
  146.     case OBJ:
  147.             val = xlsend(fun.n_ptr,args.n_ptr);
  148.             break;
  149.  
  150.     default:
  151.             xlfail("bad function");
  152.     }
  153.  
  154.     xlstack = oldstk;                            /* Restore old stack frame */
  155.     tpop();                                      /* Remove trace entry */
  156.     return (val);                                /* and return result value */
  157. }
  158.  
  159.  
  160.  
  161.                          /******************************
  162.                          *  evsym - evaluate a symbol  *
  163.                          ******************************/
  164.  
  165. static struct node *evsym(sym)
  166.     struct node *sym;
  167. {
  168.     struct node *lptr;
  169.  
  170.     if ((lptr = xlobsym(sym)) != NULL)           /* Check for current object */
  171.         return (lptr->n_listvalue);
  172.     else
  173.         return (sym->n_symvalue);
  174. }
  175.  
  176.  
  177.                         /********************************
  178.                         *  evfun - evaluate a function  *
  179.                         ********************************/
  180.  
  181. static struct node *evfun(fun,args)
  182.     struct node *fun,*args;
  183. {
  184.     struct node *oldenv,*oldstk,cptr,*fargs,*val;
  185.  
  186.     oldstk = xlsave(&cptr,NULL);                 /* Creat a new stack frame */
  187.  
  188.                                             /* get the formal argument list */
  189.     if ((fargs = fun->n_listvalue) != NULL && fargs->n_type != LIST)
  190.         xlfail("bad formal argument list");
  191.  
  192.     oldenv = xlenv;                              /* Bind the formal parameters*/
  193.     xlabind(fargs,args);
  194.     xlfixbindings(oldenv);
  195.  
  196.     for (cptr.n_ptr = fun->n_listnext; cptr.n_ptr != NULL; )    /* execute */
  197.         val = xlevarg(&cptr.n_ptr);
  198.  
  199.     xlunbind(oldenv);                            /* Restore environment */
  200.     xlstack = oldstk;                            /* ..then the stack frame */
  201.     return (val);                                /* ...and return result */
  202. }
  203.  
  204.  
  205.  
  206.                 /************************************************
  207.                 *  xlabind - bind the arguments for a function  *
  208.                 ************************************************/
  209.  
  210. xlabind(fargs,aargs)
  211.     struct node *fargs,*aargs;
  212. {
  213.     struct node *oldstk,farg,aarg,val;
  214.  
  215.     oldstk = xlsave(&farg,&aarg,&val,NULL);      /* Create a stack frame */
  216.  
  217.     farg.n_ptr = fargs;                          /* Initialze the pointers */
  218.     aarg.n_ptr = aargs;
  219.  
  220.     while (farg.n_ptr != NULL && aarg.n_ptr != NULL)  /* evaluate and bind */
  221.     {
  222.         if (farg.n_ptr->n_listvalue == slash)    /* Check for local separator*/
  223.             break;
  224.  
  225.         val.n_ptr = xlevarg(&aarg.n_ptr);        /* Evaluate the arg */
  226.         xlbind(farg.n_ptr->n_listvalue,val.n_ptr);    /* ..and bind to formal */
  227.  
  228.         farg.n_ptr = farg.n_ptr->n_listnext;     /* Move pointer ahead */
  229.     }
  230.  
  231.                                                  /* check for local variables */
  232.     if (farg.n_ptr != NULL && farg.n_ptr->n_listvalue == slash)
  233.         while ((farg.n_ptr = farg.n_ptr->n_listnext) != NULL)
  234.             xlbind(farg.n_ptr->n_listvalue,NULL);
  235.  
  236.     xlstack = oldstk;                            /* Restore old stack frame */
  237.  
  238.     if (farg.n_ptr != aarg.n_ptr)                /* Check for correct # */
  239.         xlfail("incorrect number of arguments to a function");
  240. }
  241.  
  242.  
  243.  
  244.                       /************************************
  245.                       *  xlfail - error handling routine  *
  246.                       ************************************/
  247.  
  248. xlfail(err)
  249.     char *err;
  250. {
  251.     printf("error: %s\n",err);         /* Print the error message */
  252.     xlunbind(NULL);                    /* Unbind any bound symbols */
  253.     xltin(TRUE);                       /* Restore input to terminal */
  254.     trace();                           /* Do the back trace */
  255.     trace_pointer = -1;
  256.     xlabort();                         /* Restart */
  257. }
  258.  
  259.  
  260.                   /********************************************
  261.                   *  tpush - add an entry to the trace stack  *
  262.                   ********************************************/
  263.  
  264. static tpush(nptr)
  265.     struct node *nptr;
  266. {
  267.     if (++trace_pointer < TDEPTH)
  268.         trace_stack[trace_pointer] = nptr;
  269. }
  270.  
  271.  
  272.  
  273.                  /*********************************************
  274.                  *  tpop - pop an entry from the trace stack  *
  275.                  *********************************************/
  276.  
  277. static tpop()
  278. {
  279.     trace_pointer--;
  280. }
  281.  
  282.  
  283.  
  284.                           /****************************
  285.                           *  trace - do a back trace  *
  286.                           ****************************/
  287.  
  288. static trace()
  289. {
  290.     for (; trace_pointer >= 0; trace_pointer--)
  291.         if (trace_pointer < TDEPTH)
  292.          {
  293.             xlprint(trace_stack[trace_pointer],TRUE);
  294.             putchar('\n');
  295.         }
  296. }
  297.  
  298.  
  299.  
  300.                     /***************************************
  301.                     *  xleinit - initialize the evaluator  *
  302.                     ***************************************/
  303.  
  304. xleinit()
  305. {
  306.     slash = xlenter("/");              /* the local variable separator */
  307.  
  308.     trace_pointer = -1;                /* Initialize debugging */
  309.  
  310.     xlsubr("eval",eval);               /* Built in functions from this module */
  311. }
  312.